home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / PICKLIST.PRG < prev    next >
Encoding:
Text File  |  1993-11-22  |  86.0 KB  |  2,155 lines
  1. *-----------------------------------------------------------------------
  2. *-- Program..: PICKLIST.PRG
  3. *-- Date.....: 09/02/1993
  4. *-- Notes....: This new (as of November, 1992) section of the DUFLP
  5. *--            library is designed to be a place where a variety of
  6. *--            picklist routines will be stored. You can ... ahem ...
  7. *--            pick and choose the one(s) you need from here.
  8. *-- WARNING..: Do not save changes with WordStar 5.5 Non_Document mode
  9. *--            --the diacritical characters in the DIACRIT procedure
  10. *--            below will not be saved properly (WordStar doesn't like
  11. *--            high ASCII characters ...)
  12. *-----------------------------------------------------------------------
  13.  
  14. FUNCTION Pick1
  15. *-----------------------------------------------------------------------
  16. *-- Programmer..: Kenneth W. Holloway (HollowayK on BORBBS)
  17. *-- Date........: 11/01/1993
  18. *-- Notes.......: Pick List.
  19. *-- Written for.: dBASE IV, 1.5
  20. *-- Rev. History: 08/12/1992 0.0 - Original version (KWH)
  21. *--               09/11/1992 0.1 - (KWH) Added color settings
  22. *--                                (x_ClrP*) that were Ass-U-Med to
  23. *--                                be defined elsewhere.
  24. *--               09/16/1992 0.2 - (KWH) Added "set key to" at end
  25. *--                                of function. (BORLAND: What
  26. *--                                happened to set("KEY")?!?!)
  27. *--               10/14/1992 0.3 - Added (KenMayer) ability to pass
  28. *--                                colors to program ... removed
  29. *--                                settings for alias, order, key.
  30. *--                                The reason is a lack of stack
  31. *--                                space to call routine, can only
  32. *--                                send x number of parms. The
  33. *--                                programmer must set the database
  34. *--                                (select .../Use ...), order, and
  35. *--                                key (set key...) before calling
  36. *--                                this routine, and then reset to
  37. *--                                prior setting (if needed).
  38. *--               10/15/1992 0.4 - (KWH) Added code for Tab/Shift
  39. *--                                Tab. Put the setting for key back
  40. *--                                in, as it is required for proper
  41. *--                                SEEKing with SET KEY in effect.
  42. *--               10/19/1992 0.5 - (KWH) Several changes inspired by
  43. *--                                JOEY:
  44. *--                              ˛ Now uses setting of SET BORDER TO
  45. *--                                when drawing borders.
  46. *--                              ˛ Bell only sounds when SET BELL is
  47. *--                                ON.
  48. *--                              ˛ Added code for {Home} and {End}.
  49. *--               11/06/1992 0.6 - (KWH) Optimization inspired by
  50. *--                                KELVIN:
  51. *--                              ˛ Removed repetitive recalculation
  52. *--                                of PICTURE clause
  53. *--                              ˛ Removed some dead code
  54. *--                              ˛ Added a logical variable for main
  55. *--                                loop, instead of four .and.ed
  56. *--                                expressions
  57. *--               02/22/1993 -- Minor change to PRIVATE calls.
  58. *--               11/01/1993 -- Changes suggested by David Jellison
  59. *--                             (CAI, via Internet) to give a cleaner
  60. *--                             title bar.
  61. *-- Calls.......: ColorBrk()           Function in PROC.PRG
  62. *-- Called by...: Any
  63. *-- Usage.......: Pick1(cTitle,cDisplay,cReturn[,cKey[,nFromrow, ;
  64. *--                     nFromcol[,nTorow,nTocol[,cColor1[,cColor2]]]]])
  65. *-- Example.....: ? Pick1("Client Name","NAME","JOB_CODE","",5,10,20,55,;
  66. *--                       cColor1,cColor2)
  67. *-- Returns.....: Specified expression, using macro substitution.
  68. *-- Parameters..: cTitle    = Title to be displayed above PickList
  69. *--               cDisplay  = Expression to display, using macro 
  70. *--                           substitution 
  71. *--                     Note: If cDisplay includes any chr(29)'s (), 
  72. *--                           the Tab and Shift Tab keys can be used to 
  73. *--                           highlight/unhighlight everything up to 
  74. *--                           the next/previous chr(29). 
  75. *--               cReturn   = Expression to return, using macro 
  76. *--                           substitution 
  77. *--               cKey      = Expression for SET KEY TO
  78. *--               nFromrow  \ Upper left corner
  79. *--               nFromcol  / of PickList window
  80. *--               nTorow    \ Lower right corner
  81. *--               nTocol    / of PickList window
  82. *--               cColor1   = message,title,box
  83. *--               cColor2   = highlight,selected
  84. *--                           Both cColor1 and cColor2 use specific 
  85. *--                           color settings of <Foreground> / 
  86. *--                           <Background>  for each part of the parm. 
  87. *--                           For example, cColor1 might look like:  
  88. *--                           rg+/gb,w+/b,rg+/gb 
  89. *--                           Definitions:
  90. *--                            message   = unselected items in picklist
  91. *--                                        (w+/rb) 
  92. *--                            title     = title at top of window 
  93. *--                                        (w+/rb) 
  94. *--                            box       = border (rg+/rb)
  95. *--                            highlight = highlighted item (g+/n) 
  96. *--                            selected  = selected character(s) 
  97. *--                                        (r+/n)
  98. *-----------------------------------------------------------------------
  99.    parameters  cTitle, cDisplay, cReturn, cKey, nFromrow, nFromcol, ;
  100.                nTorow, nTocol,  cColor1, cColor2 
  101.  
  102.    private all except _p*
  103.  
  104.    * Check validity of all parameters
  105.    if pcount()<3
  106.       RETURN "***"+PROGRAM()+" Error***"
  107.    endif
  108.  
  109.    * Save setting of TALK and turn it off.
  110.    m->cTalk       = SET("TALK")
  111.    set talk off
  112.   
  113.    * Save and change settings of other parameters
  114.    m->cConsole    = set("CONSOLE")
  115.    m->cCursor     = set("CURSOR")
  116.    m->cEscape     = set("ESCAPE")
  117.    set cursor        off
  118.    set escape        off
  119.   
  120.    * set default values for unspecified parameters
  121.    if type("cKey")="L"
  122.       m->cKey      = ""
  123.    endif
  124.    if type("nFromrow")="L"
  125.       m->nFromrow  = 5
  126.    endif
  127.    if type("nFromcol")="L"
  128.       m->nFromcol  = 5
  129.    endif
  130.    
  131.    if type("cColor1")="L"
  132.       m->x_Clrpmess  = "W+/RB"
  133.       m->x_Clrptitl  = "W+/RB"
  134.       m->x_Clrpbox   = "RG+/RB"
  135.    else
  136.       m->x_Clrpmess  = colorbrk(m->cColor1,1)
  137.       m->x_Clrptitl  = colorbrk(m->cColor1,2)
  138.       m->x_Clrpbox   = colorbrk(m->cColor1,3)
  139.    endif
  140.    if type("cColor2")="L"
  141.       m->x_Clrphigh  = "G+/N"
  142.       m->x_Clrpslct  = "R+/N"
  143.    else
  144.       m->x_Clrphigh  = colorbrk(m->cColor2,1)
  145.       m->x_Clrpslct  = colorbrk(m->cColor2,2)
  146.    endif
  147.  
  148.    *-- Real code starts here
  149.    * setup specified database environment
  150.    if .not.isblank(m->cKey)
  151.       set key to m->cKey
  152.    endif
  153.    
  154.    * Calculate value of m->nTorow
  155.    if type("nTorow")="L"
  156.       goto top
  157.       count to m->nTorow next 21-m->nFromrow
  158.       m->nTorow    = m->nFromrow + max(m->nTorow,3) + 3
  159.    endif
  160.  
  161.    * Calculate value of m->nTocol
  162.    if type("nTocol")="L"
  163.       m->nTocol    = m->nFromcol + max(len(m->cTitle), ;
  164.                      len(&cDisplay.)) + 1 
  165.       if m->nTocol>79
  166.          m->nTocol  = 79
  167.       endif
  168.    endif
  169.  
  170.    * Define and activate title window, draw border and title
  171.                                                                       
  172.    define window wPickList1 from  m->nFromRow,m->nFromCol       ;
  173.                             to    m->nTorow, m->nTocol none  ;
  174.                             color &x_Clrpmess.
  175.   
  176.    activate window wPickList1
  177.    m->nWindrow  = m->nTorow - m->nFromRow
  178.    m->nWindcol  = m->nTocol - m->nFromCol
  179.    @ 00,00 to m->nWindrow,m->nWindcol  color &x_Clrpbox.
  180.    m->nCenter = ((m->nToRow-m->nFromRow)-len(m->cTitle))/2
  181.    @ 01,01 fill to 01,((m->nToRow-nFromRow)-2) color &x_clrPTitl.
  182.    @ 01,m->nCenter say trim(m->cTitle)         color &x_Clrptitl.
  183.    @ 02,01 to 02,m->nWindcol-1                 color &x_Clrpbox.
  184.    m->cBorder = set("BORDER")
  185.    do case
  186.       case m->cBorder="NONE"
  187.       case m->cBorder="SINGLE"
  188.          @ 02,00          say "√"         color &x_Clrpbox.
  189.          @ 02,m->nWindcol say "¥"         color &x_Clrpbox.
  190.       case m->cBorder="DOUBLE"
  191.          @ 02,00          say "Ã"         color &x_Clrpbox.
  192.          @ 02,m->nWindcol say "π"         color &x_Clrpbox.
  193.       case m->cBorder="PANEL"
  194.          @ 02,00          say "€"         color &x_Clrpbox.
  195.          @ 02,m->nWindcol say "€"         color &x_Clrpbox.
  196.       otherwise
  197.          @ 02,00          say chr(val(substr(m->cBorder,17,3)))  ;
  198.                                color &x_Clrpbox.
  199.          @ 02,m->nWindcol say chr(val(substr(m->cBorder,21,3)))  ;
  200.                                color &x_Clrpbox.
  201.    endcase
  202.  
  203.    * define and activate data window
  204.    define window wPickList2 from  nFromRow+3,nFromCol+1  ;
  205.                             to    nTorow-1,nTocol-1 none ;
  206.                             color &x_Clrpmess. 
  207.    
  208.    activate window wPickList2
  209.    m->nWindrow  = m->nTorow - m->nFromRow-4
  210.    m->nWindcol  = m->nTocol - m->nFromCol-2
  211.    m->cWindpict = replicate('X',m->nWindcol+1)
  212.  
  213.    * Initialize position and status variables
  214.    goto top
  215.    m->lBell     = (set("BELL")="ON")
  216.    m->nCurrow   = 0
  217.    m->nInkey    = 0
  218.    m->nNewrow   = 0
  219.    m->nRecno    = recno()
  220.    m->lRepaint  = .T.
  221.    m->cSeek     = ""
  222.    m->lSeek     = .F.
  223.    m->nNewscur  = 0
  224.    m->nSeekCur  = 0
  225.    if eof()
  226.       if m->lBell
  227.          @ 00,00 say chr(7)
  228.       endif
  229.       @ 00,00 say "*** No records to list ***"
  230.       set console off
  231.       wait
  232.       set console on
  233.       m->cReturn = ""
  234.       m->nInkey  = 27
  235.    endif
  236.  
  237.    *-- Display PickList until Enter .or. Ctrl-Q .or. Ctrl-W or Ctrl-End
  238.    *-- .or. Esc is pressed
  239.    m->lMore = .T.
  240.    do while m->lMore
  241.       if m->lSeek
  242.          seek m->cKey+m->cSeek
  243.          m->nNewscur    = len(m->cSeek)
  244.          m->cStr        = &cDisplay.
  245.          m->nPos        = at(chr(29),substr(m->cStr,1,m->nNewscur+1))
  246.          do while m->nPos>0
  247.             m->cStr      = stuff(m->cStr,m->nPos,1," ")
  248.             m->nNewscur  = m->nNewscur + 1
  249.             m->nPos      = at(chr(29),substr(m->cStr,1,m->nNewscur+1))
  250.          enddo
  251.          m->nSeek = recno()                && Save new record number
  252.          n     = 0                         && counter
  253.          goto m->nRecno                    && Record at top of screen
  254.          * Look to see if new record is on screen
  255.          scan while recno()#m->nSeek .and. m->n < m->nMaxrow
  256.             m->N = m->N + 1
  257.          endscan
  258.          if recno()=m->nSeek           && New record is on screen
  259.             m->nNewrow = m->N          && Put cursor on new record
  260.          else                          && New record is not on screen
  261.             m->nNewrow   = 0           && Put cursor at top of window
  262.             m->nRecno    = m->nSeek    && New record at top of window
  263.             m->lRepaint  = .T.         && Redisplay window
  264.          endif
  265.          m->lSeek = .F.
  266.       endif
  267.    
  268.       if m->lRepaint .OR. m->nNewrow#m->nCurrow
  269.          * Hide cursor
  270.          @ m->nCurrow,00 FILL to m->nCurrow,m->nWindcol ;
  271.                          color &x_Clrpmess.
  272.       endif
  273.       
  274.       if m->lRepaint         && Need to redisplay entire data window
  275.          goto m->nRecno      && Record that should be at top of window
  276.          m->nMaxrow = 0      && Number of rows displayed
  277.          scan while m->nMaxrow<=m->nWindrow  && m->nWindrow = number of
  278.             * Display data                   &&   rows in window
  279.             @ m->nMaxrow,00 say &cDisplay. picture m->cWindpict ;
  280.                             color &x_Clrpmess.
  281.             m->nMaxrow = m->nMaxrow + 1      && Increase rows displayed 
  282.          endscan                             &&   counter
  283.          m->nMaxrow = m->nMaxrow - 1         && Make rows displayed 
  284.                                              &&    counter zero-based
  285.          if eof() .and. m->nMaxrow<m->nWindrow   && Didn't fill window?
  286.             * Clear unused portion of window
  287.             @ m->nMaxrow+1,00 clear to m->nWindrow,m->nWindcol
  288.          endif
  289.       endif
  290.    
  291.       if m->lRepaint .or. m->nNewrow#m->nCurrow ;
  292.                      .or. m->nNewscur#m->nSeekCur
  293.          m->nSeekCur   = m->nNewscur  && New seek cursor length
  294.          m->nCurrow    = m->nNewrow   && New cursor position
  295.          if m->nCurrow > m->nMaxrow   && Cursor row invalid? (Caused by 
  296.                                       &&   PgDn)
  297.             m->nCurrow = m->nMaxrow   &&Put cursor on last displayed row
  298.          endif
  299.       
  300.          * Display cursor
  301.          if m->nSeekCur>0
  302.             @ m->nCurrow,00;
  303.                fill to m->nCurrow,min(m->nWindcol,m->nSeekCur-1);
  304.                color &x_Clrpslct.
  305.          endif
  306.          if m->nSeekCur<=m->nWindcol
  307.             @ m->nCurrow,max(0,m->nSeekCur);
  308.                fill to m->nCurrow,m->nWindcol;
  309.                color &x_Clrphigh.
  310.          endif
  311.       endif
  312.    
  313.       m->lRepaint = .F.               && Reset redisplay flag   
  314.       m->nInkey = inkey(0)            && Get a key-stroke
  315.       do case
  316.          case m->nInkey=-400             && Shift-Tab
  317.             if isblank(m->cSeek)
  318.                if m->lBell
  319.                   @ 00,00 say chr(7)
  320.                endif
  321.             else
  322.                if len(m->cSeek)=m->nSeekCur
  323.                   m->cSeek = ""
  324.                   m->lSeek = .T.
  325.                else
  326.                   goto m->nRecno         && Record at top of window
  327.                   skip m->nCurrow        && Cursor row
  328.                   * Currently seeked string
  329.                   m->cStr  = substr(&cDisplay.,1,m->nSeekCur)
  330.                   * if the last character is a chr(29)
  331.                   if substr(m->cStr,len(m->cStr),1)=chr(29)
  332.                      * Remove the chr(29)
  333.                      m->cStr  = substr(m->cStr,1,len(m->cStr)-1)
  334.                   endif
  335.                   * if there is a chr(29)
  336.                   if chr(29)$m->cStr
  337.                      * Remove everything after the last chr(29)
  338.                      m->cSeek = substr(m->cSeek, 1,                 ;
  339.                                        len(m->cSeek)-len(m->cStr) + ;
  340.                                        Rat(chr(29), m->cStr))
  341.                   else
  342.                      * Remove everything
  343.                      m->cSeek = ""
  344.                   endif
  345.                   m->lSeek = .T.
  346.                endif
  347.             endif
  348.         
  349.          case m->nInkey=3               && PageDown
  350.             m->cSeek     = ""           && clear seek string
  351.             m->nNewscur  = 0            && clear seek cursor
  352.             if m->nCurrow=m->nMaxrow    
  353.                                     && Is cursor on last line in window?
  354.                goto m->nRecno           && Record at top of window
  355.                skip m->nWindrow+1       && Number of records in window
  356.                if eof()
  357.                   if m->lBell
  358.                      @ 00,00 say chr(7) 
  359.                                        && No more records past bottom of
  360.                   endif                &&   window
  361.                else
  362.                   skip -1              && Put bottom record at top of 
  363.                                        &&   window
  364.                   m->nRecno    = recno()  
  365.                                        && New record for top of window
  366.                   m->lRepaint  = .T.   && Redisplay window
  367.                endif
  368.             else                       && Cursor is not on last line in 
  369.                                        &&   window
  370.                 m->nNewrow = m->nMaxrow  && Put cursor on last line in 
  371.             endif                        &&   window
  372.       
  373.          case m->nInkey=5                  && Up Arrow
  374.             m->cSeek     = ""              && clear seek string
  375.             m->nNewscur  = 0               && clear seek cursor
  376.             if m->nCurrow>0                && Is cursor below top of 
  377.                                            && window?
  378.                m->nNewrow = m->nCurrow - 1 && Move cursor up
  379.             else                           && Cursor is at top of window
  380.                goto m->nRecno              && Record at top of window
  381.                skip -1  
  382.                if bof()
  383.                   if m->lBell
  384.                      @ 00,00 say chr(7)    && No previous record
  385.                   endif
  386.                else
  387.                   m->nRecno    = recno() && New record for top of window
  388.                   m->lRepaint  = .T.       && Redisplay window
  389.                endif
  390.             endif
  391.       
  392.          case m->nInkey=9                  && Tab
  393.             goto m->nRecno                 && Record at top of window
  394.             skip m->nCurrow                && Cursor row
  395.             * Characters after currently seeked string
  396.             m->cStr  = substr(&cDisplay.,m->nSeekCur+1)
  397.             if (chr(29)$m->cStr)           && Tab marker included?
  398.                * Seek everything up to the tab marker
  399.                m->cStr  = substr(m->cStr,1,at(chr(29),m->cStr)-1)
  400.                if .not. seek(m->cKey+m->cSeek+m->cStr)
  401.                   m->cStr  = upper(m->cStr)
  402.                endif
  403.                if seek(m->cKey+m->cSeek+m->cStr)
  404.                   m->cSeek = m->cSeek + m->cStr
  405.                   m->lSeek = .T.
  406.                else
  407.                   if m->lBell
  408.                      @ 00,00 say chr(7)
  409.                   endif
  410.                endif
  411.             else
  412.                if m->lBell
  413.                   @ 00,00 say chr(7)
  414.                endif
  415.             endif
  416.       
  417.           case m->nInkey=13 .or. m->nInkey=23
  418.                                            && Enter, Ctrl-W, or Ctrl-End
  419.              goto m->nRecno                && Record at top of window
  420.              skip m->nCurrow               && Cursor row
  421.              m->cReturn = &cReturn.        && Return value
  422.              m->lMore   = .F.              && Exit main loop
  423.  
  424.           case m->nInkey=17 .or. m->nInkey=27   && Ctrl-Q .or. Escape
  425.              m->cReturn = ""               && Return value
  426.              m->lMore   = .F.              && Exit main loop
  427.       
  428.          case m->nInkey=18                && Page Up
  429.             m->cSeek     = ""             && clear seek string
  430.             m->nNewscur  = 0              && clear seek cursor
  431.             if m->nCurrow=0               && Is cursor on top line of 
  432.                                           && window?
  433.                goto m->nRecno             && Record at top of window
  434.                skip -m->nWindrow          && Number of records in window
  435.                if bof()
  436.                   if m->lBell
  437.                      @ 00,00 say chr(7) && No more records above top of 
  438.                   endif                 &&   window
  439.                else
  440.                   m->nRecno    = recno() && New record for top of window
  441.                   m->lRepaint  = .T.     && Redisplay window
  442.                endif
  443.             else                         && Cursor is not on top line of
  444.                                          &&   window
  445.                 m->nNewrow = 0           && Put cursor on top line of 
  446.             endif                        &&   window
  447.        
  448.          case m->nInkey=24               && Down Arrow
  449.             m->cSeek     = ""            && clear seek string
  450.             m->nNewscur  = 0             && clear seek cursor
  451.             if m->nCurrow<m->nMaxrow     && Is cursor above bottom of 
  452.                                          &&   window?
  453.                 m->nNewrow = m->nCurrow + 1  && Move cursor down
  454.             else                        && Cursor is at bottom of window
  455.                goto m->nRecno           && Record at top of window
  456.                skip m->nWindrow+1       && skip to first record below 
  457.                if eof()                 &&   window
  458.                   if m->lBell           
  459.                      @ 00,00 say chr(7)  && No records below window
  460.                   endif
  461.                else
  462.                   goto m->nRecno            && Record at top of window
  463.                   skip +1
  464.                   m->nRecno    = recno() && New record for top of window
  465.                   m->lRepaint  = .T.     && Redisplay window
  466.                endif
  467.             endif
  468.         
  469.          case m->nInkey=2 .or. m->nInkey=30 && End .or. Ctrl-Page Down
  470.             m->cSeek     = ""               && clear seek string
  471.             m->nNewscur  = 0                && clear seek cursor
  472.             goto bottom                     && Last record in database
  473.             skip -m->nWindrow               && Number of records in 
  474.                                             && window
  475.             m->nNewrow   = m->nWindrow      && Put cursor on bottom line
  476.                                             && of window
  477.             m->nRecno    = recno()       && New record for top of window
  478.             m->lRepaint  = .T.           && Redisplay window
  479.       
  480.          case m->nInkey=26 .or. m->nInkey=31 && Home .or. Ctrl-Page Up
  481.             m->cSeek     = ""                && clear seek string
  482.             m->nNewscur  = 0                 && clear seek cursor
  483.             goto top                         && First record in database
  484.             m->nNewrow   = 0                 &&Put cursor on top line of
  485.                                              &&   window
  486.             m->nRecno    = recno()           && New record for top of 
  487.                                              &&   window
  488.             m->lRepaint  = .T.               && Redisplay window
  489.       
  490.           case m->nInkey>31 .and. m->nInkey<127  
  491.                                              && Displayable character -
  492.                                              &&   Seek it
  493.             m->cInkey  = chr(m->nInkey)
  494.             if .not. seek(m->cKey+m->cSeek+m->cInkey)
  495.                m->cInkey  = upper(m->cInkey)
  496.             endif
  497.             if seek(m->cKey+m->cSeek+m->cInkey)    && Seek with new 
  498.                                                    &&   character
  499.                m->cSeek     = m->cSeek + m->cInkey && Add new character
  500.                m->lSeek     = .T.                  &&   to seek string
  501.             else
  502.                if m->lBell
  503.                   @ 00,00 say chr(7)          && Seek with new character
  504.                endif                          &&   failed
  505.             endif
  506.       
  507.          case m->nInkey=127                  && Back Space
  508.             if len(m->cSeek)>0               && Seek string is non-blank
  509.                * Remove last character from seek string
  510.                m->cSeek = left(m->cSeek,len(m->cSeek)-1)
  511.                m->lSeek = .T.
  512.             else
  513.                if m->lBell
  514.                   @ 00,00 say chr(7)         && Seek string is blank
  515.                endif
  516.             endif
  517.       
  518.          otherwise                    && Unknown key
  519.             B=.T.                     && Breakpoint - used for debugging
  520.             release B
  521.       endcase
  522.    enddo
  523.  
  524.    * Deactivate and release windows
  525.    deactivate window wPickList2
  526.    deactivate window wPickList1
  527.    release windows wPickList1,wPickList2
  528.  
  529.    * Restore database environment
  530.    if .not.isblank(m->cKey)
  531.       set key to
  532.    endif
  533.  
  534.    *-- Cleanup
  535.    set console       &cConsole.
  536.    set cursor        &cCursor.
  537.    set escape        &cEscape.
  538.    set talk          &cTalk.
  539.   
  540. RETURN m->cReturn
  541. *-- EoF: Pick1()
  542.  
  543. FUNCTION Pick2
  544. *-----------------------------------------------------------------------
  545. *-- Programmer..: Malcolm C. Rubel
  546. *-- Date........: 05/18/1992
  547. *-- Notes.......: I stole ... er ... lifted ... this from Data Based 
  548. *--               Advisor (Nov. 1991), and dUFLPed it, as well as 
  549. *--               removing the FoxPro code ... It's purpose is to 
  550. *--               create a popup/picklist that will find the proper 
  551. *--               location (used with a GET) on the screen for itself, 
  552. *--               display the popup and return the appropriate value 
  553. *--               ... 
  554. *-- Written for.: dBASE IV, 1.1
  555. *-- Rev. History: 11/01/1991 -- Malcom C. Rubel -- Original Code
  556. *--               05/15/1992 -- Ken Mayer -- several things. First, I 
  557. *--               dUFLPed the code, and documented it heavier than the 
  558. *--               original. next, I had to write a function (USED()), 
  559. *--               as there wasn't one sitting around that I could see. 
  560. *--               I added the 'cTag' parameter, as well as a few minor 
  561. *--               changes to the other functions that come with this 
  562. *--               routine ... 
  563. *--               05/19/1992 -- Resolved a few minor problems, removed 
  564. *--               routine PK_SHOW as being unnecessary (used @Getrow... 
  565. *--               GET to redisplay field/memvar). Added IsBlank() (copy
  566. *--               of EMPTY()) to handle different field types (original 
  567. *--               only wanted characters).
  568. *-- Calls.......: ScrRow()         Function in SCREEN.PRG (and here)
  569. *--               ScrCol()         Function in SCREEN.PRG (and here)
  570. *--               Used()           Function in FILES.PRG (and here)
  571. *-- Called by...: Any
  572. *-- Usage.......: Pick2("<cLookfile>","<cTag>","<cSrchfld>", ;
  573. *--                     "<cRetfld>",<nScrrow>,<nScrcol>)
  574. *-- Example.....: @10,20 get author ;
  575. *--                      valid required pick2("Library","Author",;
  576. *--                      "Last","Last",10,20)
  577. *-- Returns.....: lReturn (found/replaced a value or not ...)
  578. *-- Parameters..: cLookfile = file to lookup in
  579. *--               cTag      = MDX Tag to use (if blank, will use the 
  580. *--                           first tag in the MDX file, via the TAG(1) 
  581. *--                           option ...) 
  582. *--               cSrchfld  = field(s) to browse -- if blank, function 
  583. *--                           will try to use a field of same name as 
  584. *--                           what cursor is on. 
  585. *--               cRetfld   = name of field value is to be returned 
  586. *--                           from. 
  587. *--               nScrrow   = screen-row (of GET) -- if blank, function 
  588. *--                           will determine (use ,, to blank it ... or 
  589. *--                           0) 
  590. *--               nScrcol   = screen-col (of GET) -- if blank, function 
  591. *--                           will determine 
  592. *-----------------------------------------------------------------------
  593.  
  594.    parameters cLookfile, cTag, cSrchfld, cRetfld, nScrrow, nScrcol
  595.  
  596.    private cLookfile, cSrchfld, cRetfld, nScrrow, nScrcol, cVarName,;
  597.            xValReturn, lWasopen, cCurrbuff, lExact, lReturn, lIsfound,;
  598.            cBarfields, nWinWidth, nGetrow, nGetcol
  599.  
  600.    m->lReturn = .T.                 && return value must be a logical 
  601.                                     &&   assume the best ...
  602.    m->cVarName = varread()          && name of the variable at GET
  603.    m->xVarvalue = &cVarName.        && value of the variable at GET
  604.  
  605.    *-- was a 'fieldname' to get value from passed to function?
  606.    if isblank(m->cRetfld)           && passed as a null
  607.       m->cRetfld = m->cSrchfld      && we'll return contents of same 
  608.                                     && name as the search field
  609.    endif
  610.  
  611.    m->nScrrow = ScrRow()            && get row for picklist
  612.    m->nScrcol = ScrCol()            && get column for picklist
  613.    m->cCurrbuff = alias()           && current buffer (work area)
  614.    m->lExact = set("EXACT") = "ON"  && store status of 'EXACT'
  615.    set exact on                     && we want 'exact' matches ...
  616.  
  617.    *-- deal with the 'lookup' file -- if not open, open it, if open,
  618.    *-- select it ...
  619.    if .not. used(m->cLookfile)      && file not open
  620.       select select()               && find next open area
  621.       use &cLookfile.               && open file
  622.       m->lWasopen = .F.
  623.    else
  624.       select (m->cLookfile)         && file IS open, move to it ...
  625.       m->lWasopen = .T.
  626.    endif
  627.  
  628.    *-- deal with MDX tag for 'lookup' file ...
  629.    if len(trim(m->cTag)) = 0        && if a null tag was sent,
  630.       set order to tag(1)           && set the order to first tag
  631.    else
  632.       set order to &cTag.         && set it to what user passed.
  633.    endif
  634.  
  635.    *-- screen positions ...
  636.    m->nGetrow = row()               && position of 'get' on screen
  637.    m->nGetcol = Iif(isblank(m->xVarvalue),col(),col()-len(&cRetfld.))
  638.    && get column of 'get' ...
  639.  
  640.    *-- if field is empty, do a lookup, otherwise, look for it in table
  641.    if isblank(m->xVarvalue)         && no data in field
  642.       m->lIsfound = .F.             && automatic lookup
  643.    else
  644.       m->lIsfound = seek(m->xVarvalue) && look for it in table
  645.    endif
  646.  
  647.    *-- if not found, or field was empty, bring up the lookup ...
  648.    if .not. m->lIsfound          && not in table
  649.       go top                     && move pointer to top of 'table'
  650.       *-- make sure it fits on screen
  651.       if m->cRetfld = m->cSrchfld             && one browse field
  652.          nWim->nWidth = len(&cSrchfld.) + 3   && width
  653.          m->cBarfields = m->cSrchfld          && set the 'browse fields'
  654.       else                                    && else multiple ....
  655.          nWim->nWidth = len(&cSrchfld.)+len(&cRetfld.)+5
  656.          m->cBarfields = m->cSrchfld+", "+m->cRetfld
  657.       endif
  658.    
  659.       *-- this is how we determine where to start the browse table ...
  660.       m->nScrcol = iif(m->nScrcol + nWim->nWidth>77, 77-nWim->nWidth, ;
  661.                        m->nScrcol)
  662.       m->nScrrow = iif(m->nScrrow>14,14,m->nScrrow)
  663.   
  664.       *-- set it up ...
  665.       define window wPick from m->nScrrow,m->nScrcol+2 to ;
  666.          m->nScrrow+10,m->nScrcol+nWim->nWidth+2 panel
  667.       activate window wPick
  668.       *on key label ctrl-m keyboard chr(23) 
  669.          && when user presses <enter> force an <enter> ... weird.
  670.    
  671.       *-- activate
  672.       browse fields &cBarfields. freeze &cSrchfld. noedit ;
  673.                  noappend nodelete nomenu window wPick
  674.       clear typeahead          && in case they pressed the <Enter> key
  675.       on key label ctrl-m      && reset
  676.       release window wPick
  677.       if lastkey() # 27        && not the <Esc> key
  678.          store &cRetfld. to &cVarName.  && put return value into 
  679.       else                                    &&   var ...
  680.          m->lReturn = .F.
  681.       endif
  682.    else
  683.       store &cRetfld. to &cVarName.
  684.    endif
  685.  
  686.    @m->ngetrow, m->ngetcol get &cVarName. && display new value in 
  687.                                           &&   field/memvar on screen
  688.    clear gets                             && clear gets from this 
  689.                                           &&   function
  690.    *-- reset work areas, and so on ...
  691.    if .not. m->lExact
  692.       set exact off
  693.    endif
  694.    if .not. m->lWasopen
  695.       use
  696.    endif
  697.    if len(m->cCurrbuff) # 0
  698.       select (m->cCurrbuff)
  699.    else
  700.       select select()
  701.    endif
  702.  
  703. RETURN (m->lReturn)
  704. *-- EoF: Pick2()
  705.  
  706. FUNCTION ScrRow
  707. *-----------------------------------------------------------------------
  708. *-- Programmer..: Malcolm C. Rubel
  709. *-- Date........: 05/15/1992
  710. *-- Notes.......: Returns the postion of the current 'get'. if memvar 
  711. *--               Scrrow already exists, returns the value of that, 
  712. *--               unless it's zero, in which case we return the current 
  713. *--               position. This is part of PICK2. 
  714. *-- Written for.: dBASE IV, 1.1
  715. *-- Rev. History: 11/01/1991 -- Original release 
  716. *--               05/15/1992 -- Ken Mayer (KENMAYER) to deal with a 
  717. *--               value of 0 for the nScrrow memvar. 
  718. *-- Calls.......: none
  719. *-- Called by...: Pick2()              Function in PICKLIST.PRG
  720. *-- Usage.......: Scrrow()
  721. *-- Example.....: nScrrow = Scrrow()
  722. *-- Returns.....: Numeric -- position of cursor on screen
  723. *-- Parameters..: none
  724. *-----------------------------------------------------------------------
  725.  
  726.    if type('m->nScrrow') # 'N' .or. m->nScrrow = 0
  727.       RETURN (row())
  728.    else
  729.       RETURN (m->nScrrow)
  730.    endif
  731. *-- EoF: Scrrow()
  732.  
  733. FUNCTION ScrCol
  734. *-----------------------------------------------------------------------
  735. *-- Programmer..: Malcolm C. Rubel
  736. *-- Date........: 05/15/1992
  737. *-- Notes.......: Returns the postion of the current 'get'. if memvar 
  738. *--               nScrcol already exists, returns the value of that, 
  739. *--               unless it's zero, in which case we return the current 
  740. *--               position. This will also return a different value 
  741. *--               based on whether or not the field has something in it 
  742. *--               or not ... This is part of PICK2. 
  743. *-- Written for.: dBASE IV, 1.1
  744. *-- Rev. History: 11/01/1991 -- Original release
  745. *--               05/15/1992 -- Ken Mayer (71333,1030) to deal with a 
  746. *--               value of 0 for the nScrcol memvar. 
  747. *-- Calls.......: none
  748. *-- Called By...: Pick2()
  749. *-- Usage.......: Scrcol()
  750. *-- Example.....: nScrcol = Scrcol()
  751. *-- Returns.....: Numeric -- position of cursor on screen
  752. *-- Parameters..: none
  753. *-----------------------------------------------------------------------
  754.  
  755.    if type('m->nScrcol') # 'N' .or. m->nScrcol = 0
  756.       if isblank(m->cRetfld)
  757.          RETURN col() + len(m->cRetfld)
  758.       else
  759.          RETURN col()
  760.       endif
  761.    else
  762.       RETURN (m->nScrcol)
  763.    endif
  764.  
  765. *-- EoF: Scrcol()
  766.  
  767. PROCEDURE Pick3
  768. *-----------------------------------------------------------------------
  769. *-- Programmer..: Martin Leon (HMAN) (A-T)
  770. *-- Date........: 07/12/1991
  771. *-- Notes.......: A "generic" PickList routine ...
  772. *-- Written for.: dBASE IV, 1.1
  773. *-- Rev. History: 11/01/1990 -- Original release
  774. *--               Published in TechNotes, November, 1990 (DIYPOPUP)
  775. *--               07/12/1991 -- Modified for dHUNG/dUFLP standards, Ken 
  776. *--               Mayer 
  777. *-- Calls.......: none
  778. *-- Called by...: Any
  779. *-- Usage.......: do Pick3 with "<cFields>", <nUlrow>, <nUlcol>, ;
  780. *--               <nBrrow>,<nBrcol>, "<cNormcolor>", "<cFieldColor>",; 
  781. *--               "<cBorder>" 
  782. *-- Example.....: Do Pick3 with "First_name+' '+Last_name",5,10,15,60,;
  783. *--                "rg+/gb","gb/r","DOUBLE"
  784. *-- Returns.....: indirectly returns the record pointer of record that 
  785. *--               was highlighted when <Enter> was pressed. 
  786. *-- Parameters..: cFields     = fields to be displayed in picklist
  787. *--               nUlrow      = Row coordinate of upper left corner
  788. *--               nUlcol      = Column coordinate of upper left corner
  789. *--               nBrrow      = Row coordinate of lower right corner
  790. *--               nBrcol      = Column coordinate of lower right corner
  791. *--               cNormcolor  = Foreground/Background of normal text
  792. *--               cFieldColor = Foreground/Background of highlighted 
  793. *--                             fields 
  794. *--               cBorder     = none, SINGLE, DOUBLE (defaults to 
  795. *--                             Single if sent as a nul string ("") ) 
  796. *-----------------------------------------------------------------------
  797.    parameters cFields, nUlrow, nUlcol, nBrrow, nBrcol, cNormcolor, ;
  798.               cFieldColor, cBorder
  799.  
  800.    m->cCursor = set("CURSOR")
  801.    m->cEscape = set("ESCAPE")
  802.    m->cTalk   = set("TALK")
  803.    set cursor off
  804.    set escape off
  805.    set talk off
  806.    m->cTypecheck = type("cFields") + type("nUlrow") + type("nUlcol") + ;
  807.                    type("nBrrow")  + type("nBrcol") + ;
  808.                    type("cNormcolor") + type("cFieldColor") + ;
  809.                    type("cBorder")
  810.    m->lError = .F.
  811.    do case
  812.       && Check data types
  813.       case m->cTypecheck # "CNNNNCCC"
  814.          clear
  815.          @ 7,17 say "Data type mismatch -- check all parameters"
  816.          m->lError = .T.
  817.      
  818.          && Check for bottom limit with STatUS on
  819.       case ((m->nBrrow >21 .and. set("DISPLAY") # "EGA43")    ;
  820.             .or. (m->nBrrow >39 .and. set("DISPLAY") = "EGA43")) ;
  821.             .and. set("STatUS") = "ON"
  822.          clear
  823.          @ 7,15 say "Cannot use this popup on or below Status line"
  824.          m->lError = .T.
  825.       
  826.          && Check for bottom limit with STatUS off
  827.       case ((m->nBrrow >24 .and. set("DISPLAY") # "EGA43")    ;
  828.             .or. (m->nBrrow >42 .and. set("DISPLAY") = "EGA43")) ;
  829.             .and. set("STatUS") = "off"
  830.          clear
  831.          @ 7,16 say "bottom coordinate beyond bottom of screen"
  832.          m->lError = .T.
  833.     
  834.          && Check left & right coordinates
  835.       case m->nUlcol < 0 .or. m->nBrcol > 79
  836.          clear
  837.          @ 7,24 say "Invalid Column coordinate"
  838.          m->lError = .T.
  839.     
  840.          && Check to make sure popup can display at least one record
  841.       case m->nBrrow - m->nUlrow < 2
  842.          clear
  843.          @ 7,19 say "Popup must be at least 3 lines high"
  844.          m->lError = .T.
  845.      
  846.    endcase
  847.  
  848.    if m->lError
  849.       @ 5,5 to 9,70 DOUBLE
  850.       @ 11, 32 say "Press Any Key"
  851.       m->nX = 0
  852.       do while m->nX = 0
  853.          m->nX = inkey()
  854.       enddo
  855.       set cursor &cCursor.
  856.       set escape &cEscape.
  857.       set talk &cTalk.
  858.       RETURN
  859.    endif
  860.  
  861.    && Save colors of normal and fields to restor when done
  862.    m->cFieldset = set("ATTRIBUTES")
  863.    m->cNormset = left(m->cFieldset, at(",",m->cFieldset)-1)
  864.    do while "," $ m->cFieldset
  865.       m->cFieldset = substr(m->cFieldset, at(",",m->cFieldset)+1)
  866.    enddo
  867.  
  868.    && if they were provided, set to colors passed on from calling program
  869.    if len(m->cNormcolor) # 0
  870.       set color of normal to &cNormcolor.
  871.    endif
  872.    if len(m->cFieldColor) # 0
  873.       set color of fields to &cFieldColor.
  874.    endif
  875.  
  876.    m->nPromptW = m->nBrcol - m->nUlcol - 1
  877.    @ m->nUlrow, m->nUlcol clear to m->nBrrow, m->nBrcol
  878.    @ m->nUlrow, m->nUlcol to m->nBrrow, m->nBrcol &cBorder.
  879.   
  880.    if eof()
  881.       skip -1
  882.    endif
  883.  
  884.    && Save current record pointer and determine record number of top 
  885.    &&   record
  886.    m->nTmprec = recno()
  887.    go top
  888.    m->nToprec = recno()
  889.    go m->nTmprec
  890.    m->nMaxrecs = m->nBrrow - m->nUlrow - 1
  891.    m->nKey = 0
  892.    m->lGoBack = .F.
  893.    declare aPrompt[m->nMaxrecs], aRec[m->nMaxrecs]
  894.  
  895.    do while .NOT. m->lGoBack
  896.       m->nChcnum = 1
  897.       m->nToprow = m->nUlrow + 1
  898.       m->nLeftcol = m->nUlcol + 1
  899.       m->nRowoffset = 0
  900.       m->nLastcurs = 0
  901.     
  902.       && This loop puts text into prompts
  903.       do while m->nRowoffset + 1 <= m->nMaxrecs
  904.          if .not. eof()
  905.             m->cTemp = &cFields.   && Expands m->cFields into string 
  906.                                    &&   expression
  907.             aPrompt[m->nChcnum] = substr(m->cTemp, 1, m->nPromptW)
  908.          
  909.             && if prompt doesn't fill entire box, add spaces
  910.             if len(aPrompt[m->nChcnum]) < m->nPromptW
  911.                aPrompt[m->nChcnum] = aPrompt[m->nChcnum] + ;
  912.                   space(m->nPromptW - len(aPrompt[m->nChcnum]))
  913.             endif
  914.           
  915.             aRec[m->nChcnum] = recno()
  916.             @ m->nToprow+m->nRowoffset , m->nLeftcol ;
  917.               say aPrompt[m->nChcnum]
  918.          endif
  919.          m->nRowoffset = m->nRowoffset + 1
  920.          m->nChcnum = m->nChcnum + 1
  921.          skip
  922.       
  923.          && if last record reached, clear rest of box
  924.          if eof()
  925.             do while m->nRowoffset + 1 <= m->nMaxrecs
  926.                @ m->nToprow+m->nRowoffset, m->nLeftcol ;
  927.                  say space(m->nPromptW)
  928.                m->nRowoffset = m->nRowoffset +1
  929.             enddo
  930.             exit
  931.          endif
  932.       enddo
  933.    
  934.       m->nHighchc = m->nChcnum - 1
  935.       if m->nKey # 2 .and. m->nKey # 3 && if the last key pressed wasn't
  936.                                        &&    <end> or <PgDn>
  937.          m->nChcnum = 1                  
  938.          m->nRowoffset = 0
  939.       else
  940.          m->nChcnum = m->nHighchc
  941.          m->nRowoffset = m->nHighchc - 1
  942.       endif
  943.    
  944.       @ m->nToprow+m->nRowoffset , m->nLeftcol ;
  945.         get aPrompt[m->nChcnum]
  946.       clear gets
  947.    
  948.       && This loops traps the keys
  949.       do while .T.
  950.          m->nKey = inkey()
  951.          do case
  952.          
  953.             case m->nKey = 5   && Up arrow
  954.  
  955.                && if first record displayed is first record in database
  956.                && and it is already highlighted
  957.                if aRec[1] = m->nToprec .and. m->nChcnum = 1
  958.                   loop
  959.                endif
  960.          
  961.                && if first record is highlighted but is not top record,
  962.                && shift prompt contents down
  963.                if aRec[1] # m->nToprec .and. m->nChcnum = 1
  964.                   go aRec[1]
  965.                   m->nX = m->nHighchc
  966.                   do while m->nX > 1
  967.                      aRec[m->nX] = aRec[m->nX - 1]
  968.                      aPrompt[m->nX] = aPrompt[m->nX - 1]
  969.                      m->nX = m->nX - 1
  970.                   enddo
  971.             
  972.                   && get prompt for additional record to be displayed
  973.                   skip -1
  974.                   aRec[1] = recno()
  975.                   m->cTemp = &cFields.
  976.                   aPrompt[1] = substr(m->cTemp, 1, m->nPromptW)
  977.                   if len(aPrompt[1]) < m->nPromptW
  978.                      aPrompt[1] = aPrompt[1] + ;
  979.                      space(m->nPromptW - len(aPrompt[1]))
  980.                   endif
  981.                   skip + m->nMaxrecs
  982.             
  983.                   && if maximum possible records aren't displayed
  984.                   if m->nHighchc < m->nMaxrecs
  985.                      m->nHighchc = m->nHighchc + 1
  986.                      skip -1
  987.                      aRec[m->nHighchc] = recno()
  988.                      m->cTemp = &cFields.
  989.                      aPrompt[m->nHighchc] = ;
  990.                                  substr(m->cTemp,1,m->nPromptW)
  991.                      if len(aPrompt[m->nHighchc]) < m->nPromptW
  992.                         aPrompt[m->nHighchc] = ;
  993.                           aPrompt[m->nHighchc] + ;
  994.                           space(m->nPromptW - ;
  995.                            len(aPrompt[m->nHighchc]))
  996.                      endif
  997.                      skip
  998.                   endif
  999.             
  1000.                   && Redisplay prompts with new contents
  1001.                   m->nX = 1
  1002.                   do while m->nX < m->nHighchc + 1
  1003.                      @ m->nToprow + m->nX - 1, m->nLeftcol ;
  1004.                        say aPrompt[m->nX]
  1005.                      m->nX = m->nX + 1
  1006.                   enddo
  1007.                   m->nChcnum = 2
  1008.                endif
  1009.          
  1010.                m->nChcnum = iif(m->nChcnum = 1, m->nHighchc, ;
  1011.                                 m->nChcnum - 1)
  1012.                m->nRowoffset = iif(m->nChcnum = 1, 0,;
  1013.                                       m->nChcnum - 1)
  1014.                m->nLastone = iif(m->nChcnum = m->nHighchc, 1,;
  1015.                                  m->nChcnum+1)
  1016.                m->nThisone = m->nChcnum
  1017.          
  1018.                @ m->nToprow + ;
  1019.                  iif(m->nChcnum = m->nHighchc, 0, m->nRowoffset+1) , ;
  1020.                  m->nLeftcol say aPrompt[m->nLastone]
  1021.                @ m->nToprow+m->nRowoffset , m->nLeftcol ;
  1022.                  get aPrompt[m->nThisone]
  1023.                clear gets
  1024.          
  1025.             case m->nKey = 24   && Dn arrow
  1026.           
  1027.                && if last prompt is highlighted and it is last record
  1028.                if eof() .and. m->nChcnum = m->nHighchc
  1029.                   loop
  1030.                endif
  1031.          
  1032.                &&if not at last record and bottom prompt is highlighted,
  1033.                && shift prompt contents up
  1034.                if .not. eof() .and. m->nChcnum = m->nHighchc
  1035.                   m->nX = 1
  1036.                   do while m->nX < m->nMaxrecs
  1037.                      aRec[m->nX] = aRec[m->nX + 1]
  1038.                      aPrompt[m->nX] = aPrompt[m->nX + 1]
  1039.                      m->nX = m->nX + 1
  1040.                   enddo
  1041.             
  1042.                   && get prompt for additional record to be displayed
  1043.                   aRec[m->nMaxrecs] = RECNO()
  1044.                   m->cTemp = &cFields
  1045.                   aPrompt[m->nMaxrecs] = substr(m->cTemp, 1, ;
  1046.                                                    m->nPromptW)
  1047.                   if len(aPrompt[m->nMaxrecs]) < m->nPromptW
  1048.                      aPrompt[m->nMaxrecs] = aPrompt[m->nMaxrecs]+;
  1049.                      space(m->nPromptW - len(aPrompt[m->nMaxrecs]))
  1050.                   endif
  1051.                   skip
  1052.             
  1053.                   && Redisplay prompts with new contents
  1054.                   m->nX = m->nMaxrecs
  1055.                   do while m->nX > 0
  1056.                      @ m->nToprow + m->nX - 1, m->nLeftcol ;
  1057.                        say aPrompt[m->nX]
  1058.                      m->nX = m->nX - 1
  1059.                   enddo
  1060.                   m->nChcnum = m->nMaxrecs - 1
  1061.                endif
  1062.          
  1063.                m->nChcnum = iif(m->nChcnum < m->nHighchc, ;
  1064.                                 m->nChcnum + 1, 1)
  1065.                m->nRowoffset = iif(m->nChcnum = 1, 0, m->nChcnum - 1)
  1066.                m->nLastone = iif(m->nChcnum = 1, m->nHighchc, ;
  1067.                                  m->nChcnum-1)
  1068.                m->nThisone = m->nChcnum
  1069.          
  1070.                @ m->nToprow + ;
  1071.                  iif(m->nChcnum = 1, m->nHighchc-1, m->nRowoffset-1) ,;
  1072.                      m->nLeftcol say aPrompt[m->nLastone]
  1073.                @ m->nToprow+m->nRowoffset , m->nLeftcol ;
  1074.                  get aPrompt[m->nThisone]
  1075.                clear gets
  1076.          
  1077.             case m->nKey = 13   && Enter key
  1078.                && Move record pointer and go back to calling program
  1079.                go aRec[m->nChcnum]
  1080.                m->lGoBack = .T.
  1081.                exit
  1082.          
  1083.             case m->nKey = 3    && PgDn key
  1084.          
  1085.               &&if last record in .DBF is displayed but not highlighted,
  1086.               && move highlight to bottom and wait for next key
  1087.                if eof() .and. m->nChcnum # m->nHighchc
  1088.                   @ m->nToprow + m->nRowoffset, m->nLeftcol ;
  1089.                      say aPrompt[m->nChcnum]
  1090.                   @ m->nToprow + m->nHighchc - 1, m->nLeftcol ;
  1091.                      get aPrompt[m->nHighchc]
  1092.                   clear gets
  1093.                   m->nChcnum = m->nHighchc
  1094.                   m->nRowoffset = m->nChcnum - 1
  1095.                   loop
  1096.                endif
  1097.          
  1098.                && if highlight is not on last record that is displayed,
  1099.                && move highlight to it and wait for next key
  1100.                if m->nChcnum # m->nHighchc
  1101.                   @ m->nToprow + m->nRowoffset, m->nLeftcol ;
  1102.                     say aPrompt[m->nChcnum]
  1103.                   @ m->nToprow + m->nHighchc - 1, m->nLeftcol ;
  1104.                     get aPrompt[m->nHighchc]
  1105.                   clear gets
  1106.                   m->nChcnum = m->nHighchc
  1107.                   m->nRowoffset = m->nChcnum - 1
  1108.                   loop
  1109.                endif
  1110.          
  1111.                && Highlight is at bottom record displayed but not at eof
  1112.                && Move record pointer down to next "page" of records and
  1113.                && return to main loop
  1114.                if .not. eof()
  1115.                   go aRec[1]
  1116.                   skip + m->nMaxrecs
  1117.                   m->lGoBack = .F.
  1118.                   exit
  1119.                endif
  1120.          
  1121.                && if none of the above is true, wait for another key
  1122.                loop
  1123.          
  1124.             case m->nKey = 18    && PgUp key
  1125.          
  1126.                && if top record displayed is top of .DBF but it is
  1127.                && not highlighted, move highlight to it and wait for 
  1128.                && next key
  1129.                if aRec[1] = m->nToprec .and. m->nChcnum # 1
  1130.                   @ m->nToprow + m->nRowoffset, m->nLeftcol ;
  1131.                     say aPrompt[m->nChcnum]
  1132.                   @ m->nToprow, m->nLeftcol get aPrompt[1]
  1133.                   clear gets
  1134.                   m->nChcnum = 1
  1135.                   m->nRowoffset = 0
  1136.                   loop
  1137.                endif
  1138.          
  1139.                && if highlight is not on top record displayed, move
  1140.                && highlight to it and wait for next key
  1141.                if m->nChcnum # 1
  1142.                   @ m->nToprow + m->nRowoffset, m->nLeftcol ;
  1143.                     say aPrompt[m->nChcnum]
  1144.                   @ m->nToprow, m->nLeftcol get aPrompt[1]
  1145.                   clear gets
  1146.                   m->nChcnum = 1
  1147.                   m->nRowoffset = 0
  1148.                   loop
  1149.                endif
  1150.          
  1151.                && Highlight is at top record displayed but not at top of
  1152.                && DBF. Move record pointer up one "page" worth of 
  1153.                && records and return to main loop to display new prompts
  1154.                if aRec[1] # m->nToprec
  1155.                   go aRec[1]
  1156.                   skip - m->nMaxrecs
  1157.                   m->lGoBack = .F.
  1158.                   exit
  1159.                endif
  1160.          
  1161.                && if none of the above is true, wait for next key
  1162.                loop
  1163.          
  1164.             case m->nKey = 27   && Esc key
  1165.                && Move record pointer to where it was before starting 
  1166.                && this routine and return to calling program
  1167.                m->lAbandon = .T.
  1168.                m->lGoBack = .T.
  1169.                go m->nTmprec
  1170.                exit
  1171.          
  1172.             case m->nKey = 26    && Home key
  1173.           
  1174.                && if already at top of DBF, wait for next key
  1175.                if aRec[1] = m->nToprec
  1176.                   loop
  1177.                else && go top and return to main loop to display new 
  1178.                     && prompts
  1179.                   go top
  1180.                   m->lGoBack = .F.
  1181.                   exit
  1182.                endif
  1183.          
  1184.             case m->nKey = 2    && End key
  1185.           
  1186.                &&if last record in DBF is displayed but not highlighted,
  1187.                && move highlight to it and wait for next key
  1188.                if eof() .and. m->nChcnum # m->nHighchc
  1189.                   @ m->nToprow + m->nRowoffset, m->nLeftcol ;
  1190.                     say aPrompt[m->nChcnum]
  1191.                   @ m->nToprow + m->nHighchc - 1, m->nLeftcol ;
  1192.                     get aPrompt[m->nHighchc]
  1193.                   clear gets
  1194.                   m->nChcnum = m->nHighchc
  1195.                   m->nRowoffset = m->nChcnum - 1
  1196.                   loop
  1197.                endif
  1198.          
  1199.                && if last record is not displayed, go to it and
  1200.                &&   return to main loop
  1201.                if .not. eof()
  1202.                   go bottom
  1203.                   skip - (m->nMaxrecs - 1)
  1204.                   m->lGoBack = .F.
  1205.                   exit
  1206.                endif
  1207.          
  1208.                && if none of the above is true, go back and wait for 
  1209.                && next key
  1210.                loop
  1211.          
  1212.             case m->nKey = 28  && F1 key
  1213.                && This is just sample code for the F1 key
  1214.                define window TempWin from 5,4 TO 14,75
  1215.                activate window TempWin
  1216.                @ 1,3 say "Use cursor keys to choose. " + ;
  1217.                    "Press <Enter> to move record pointer"
  1218.                @ 2,5 say "Use <PgUp>, <PgDn>, <Home>, and <End> " + ;
  1219.                    "to see other records"
  1220.                @ 3,26 say "Use <Esc> to abandon"
  1221.                @ 5,23 say "Press Any key to Continue"
  1222.                m->nX = 0
  1223.                do while m->nX = 0
  1224.                   m->nX = inkey()
  1225.                enddo
  1226.                deactivate window TempWin
  1227.          
  1228.             case m->nKey = -1  && F2 key
  1229.                && This is just sample code for the F2 key
  1230.                SAVE SCREEN TO sScreen
  1231.                m->nX = recno()
  1232.                go aRec[m->nChcnum]
  1233.                set cursor on
  1234.                EDIT NOMENU NOAPPEND NODELETE next 1
  1235.                * READ is better if you already have a FORMat set.
  1236.                set cursor off
  1237.                go aRec[m->nChcnum]
  1238.                m->cTemp = &cFields.  && Expands m->cFields into string 
  1239.                                      &&   expression
  1240.                aPrompt[m->nChcnum] = substr(m->cTemp, 1, m->nPromptW)
  1241.                if len(aPrompt[m->nChcnum]) < m->nPromptW
  1242.                   aPrompt[m->nChcnum] = aPrompt[m->nChcnum] + ;
  1243.                   space(m->nPromptW - len(aPrompt[m->nChcnum]))
  1244.                endif
  1245.                restore screen from sScreen
  1246.                @ m->nToprow+m->nRowoffset, m->nLeftcol ;
  1247.                  get aPrompt[m->nChcnum]
  1248.                clear gets
  1249.                if m->nX <= reccount()
  1250.                   go m->nX
  1251.                else
  1252.                   go bottom
  1253.                   skip
  1254.                endif
  1255.          endcase
  1256.       enddo
  1257.    enddo
  1258.  
  1259.    && Put colors back to what they were and set CURSOR, escape, and TALK 
  1260.    &&   back
  1261.    set color of normal to &cNormset.
  1262.    set color of fields to &cFieldset.
  1263.    set cursor &cCursor.
  1264.    set escape &cEscape.
  1265.    set talk &cTalk.
  1266.  
  1267. RETURN
  1268. *-- EOP: Pick3
  1269.  
  1270. FUNCTION Pick4
  1271. *---------------------------------------------------------------------
  1272. *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
  1273. *-- Date........: 11/03/1993
  1274. *-- Notes.......: This is a generic picklist routine.
  1275. *-- Written for.: dBASE IV, 1.1
  1276. *-- Rev. History: 10/01/1992 -- Original version
  1277. *--               11/03/1992 -- Modified to dUFLP it (and use RECOLOR 
  1278. *--               to ensure that colors are returned properly) -- Ken 
  1279. *--               Mayer 
  1280. *--               02/16/1993 -- Minor changes to deal with small data 
  1281. *--               files by Keith. 
  1282. *--               11/03/1993 -- Changes to fix various stuff.
  1283. *--               11/09/1993 -- Added: Select PICKER command.
  1284. *-- Calls.......: ReColor              PROCEDURE in PROC.PRG
  1285. *-- Called by...: Any
  1286. *-- Usage.......: Pick4(nRow, nCol, cTitle, cFileSpecs, cListwhat, ;
  1287. *--                     nRetchar, nRetType, cColors
  1288. *-- Example.....: ?Pick4(10,10,"Order Stock","Stock,InvNum",;
  1289. *--                     "left(invno,10)+' '+desc",4,1,"r/w,b/w,w/b")
  1290. *-- Returns.....: number of characters from prompt() or
  1291. *--               if user presses <Esc>, returns .F.
  1292. *-- Parameters..: nRow        = Upper Left Corner Row
  1293. *--               nCol        = Upper Left Corner Column
  1294. *--               cTitle      = Title to display at top of list
  1295. *--               cFileSpecs  = "FILENAME,ORDER,SET_KEY_TO"
  1296. *--               cListwhat   = What should display as prompt
  1297. *--               nRetchar    = Number of characters of prompt to
  1298. *--                             return
  1299. *--               nReturntype = 0 = KEYB(), 1 = Normal Return
  1300. *--               cColors     = Background/Unselected Items,;
  1301. *--                             Selected letters/border, selected bar
  1302. *--                             example: rg+/gb,w+/b,w+/n
  1303. *--                              rg+/gb = unselected items (and 
  1304. *--                                          background)
  1305. *--                              w+/b   = selected letter(s)
  1306. *--                              w+/n   = currently highlighted bar
  1307. *---------------------------------------------------------------------
  1308.  
  1309.    parameters nRow, nCol, cTitle, cFileSpecs, cListwhat, nRetchar, ;
  1310.               nReturntype, cColors 
  1311.  
  1312.    private nLastBar, cTalk, cStatus, cNColor, cBColor, cHColor, nPick,; 
  1313.            cWindow, cCursor, cAlias, sPick, cAttrib, nLastBar,  nDone,;
  1314.            nX, nP, nO, aBar, lRefresh, nLCol, nRCol, nPKey, cExact, ;
  1315.            cSeek, nOldRow, nOldWidth, xRetVal, cSetKey, nMaxBar
  1316.  
  1317.    m->ctalk = set("talk")
  1318.    set talk off
  1319.  
  1320.    *--------------------------------------------------------------------
  1321.    * Default colors selections.
  1322.    *     m->cBColor - Border of picklist box
  1323.    *     m->cNColor - Interior of picklist
  1324.    *     m->cHColor - selection bar
  1325.    *--------------------------------------------------------------------
  1326.  
  1327.    m->cNColor = "w/n"
  1328.    m->cBColor = "w+/n"
  1329.    m->cHColor = "n/w"
  1330.  
  1331.    * If the user passed the cColors param, set the colors accordingly
  1332.  
  1333.    if len(m->cColors) > 0
  1334.       m->nX = at(",",m->cColors)
  1335.       m->cNColor = left(m->cColors,m->nX-1)
  1336.       m->cColors = substr(m->cColors,m->nX+1)
  1337.       if len(m->cColors) > 0
  1338.          m->nX = at(",",m->cColors)
  1339.          m->cBColor = iif(m->nX > 0,left(m->cColors,m->nX-1),m->cColors)
  1340.          m->cColors = iif(m->nX > 0,substr(m->cColors,m->nX+1),"")
  1341.          if len(m->cColors) > 0
  1342.             m->cHColor = m->cColors
  1343.          endif
  1344.       endif
  1345.    endif
  1346.  
  1347.    *--------------------------------------------------------------------
  1348.    * Save the current environment as much as possible, set up our
  1349.    * preferences for the picklist.
  1350.    *--------------------------------------------------------------------
  1351.    m->cAttrib = set("attr")
  1352.    set color to &cNColor.,&cNColor.
  1353.    save screen to sPick
  1354.    m->cStatus = set("status")
  1355.    set status off
  1356.    restore screen from sPick
  1357.    m->cCursor = set("cursor")
  1358.    set cursor off
  1359.    m->cWindow = window()
  1360.    activate screen
  1361.    m->cExact = set("exact")
  1362.    m->cSeek = ""
  1363.    set exact off
  1364.    set near off
  1365.  
  1366.    *--------------------------------------------------------------------
  1367.    * Let the user know we're working....
  1368.    *--------------------------------------------------------------------
  1369.    @ 9,32 clear to 9,47
  1370.    @ 9,32 fill to 11,49 color n+/n  && shadow!
  1371.    @ 8,31 to 10,48 color &cBColor.
  1372.    @ 9,32 say " Please wait... " color &cNColor.
  1373.  
  1374.    *--------------------------------------------------------------------
  1375.    * Set up the picklist.
  1376.    *--------------------------------------------------------------------
  1377.  
  1378.    * Handle the file specs first.  The cFileSpecs parameter can have up
  1379.    * to 3 components, each separated by commas:
  1380.    *
  1381.    *           "filename,index_tag,key_range"
  1382.  
  1383.    * Results are stored in:
  1384.    *   m->cFile   - the name of the .DBF
  1385.    *   m->cOrder  - the index tag to use (if supplied)
  1386.    *   m->cSetKey - the key or key range (if supplied)
  1387.  
  1388.    m->cOrder = ""
  1389.    m->cSetKey = ""
  1390.    m->cFile = m->cFileSpecs
  1391.    m->nX = at(",",m->cFileSpecs)
  1392.    if m->nX > 0
  1393.       m->cFile= left(m->cFileSpecs,m->nX-1)
  1394.       m->cFileSpecs = substr(m->cFileSpecs,m->nX+1)
  1395.       if len(m->cFileSpecs) > 0
  1396.          m->nX = at(",",m->cFileSpecs)
  1397.          m->cOrder = iif(m->nX>0,left(m->cFileSpecs,m->nX-1), ;
  1398.                          m->cFileSpecs)
  1399.          m->cFileSpecs = iif(m->nX>0,substr(m->cFileSpecs,m->nX+1),"")
  1400.          if len(m->cFileSpecs) > 0
  1401.             m->cSetKey = m->cFileSpecs
  1402.          endif
  1403.       endif
  1404.    endif
  1405.  
  1406.    * Now save the current alieas in m->cAlias, open the file, and set up
  1407.    * the index tag and key range, if provided.
  1408.  
  1409.    m->cAlias = alias()
  1410.    use (cFile) again in select() alias picker
  1411.    select picker   && 11/9/93 -- added here -- Ken
  1412.    if len(trim(m->cOrder)) > 0
  1413.       set order to (cOrder)
  1414.    else
  1415.  
  1416.       * This block assumes you want to use a default index tag if none
  1417.       * was supplied by the user.  Comment these three lines out if
  1418.       * you prefer "natural" order to be the default.
  1419.  
  1420.       if len(tag(1)) > 0
  1421.          set order to tag(1)
  1422.       endif
  1423.    endif
  1424.    set deleted on
  1425.  
  1426.    if len(trim(m->cSetKey)) > 0
  1427.       if at(",",m->cSetKey) > 0
  1428.          m->cSetKey = "range "+ m->cSetKey
  1429.       endif
  1430.       set key to &cSetKey.
  1431.    endif
  1432.    go top
  1433.  
  1434.    * These variables are current state indicators:
  1435.    *
  1436.    *   m->nP        - the current position of the selection bar
  1437.    *   m->nO        - the most recent position of the selection bar
  1438.    *   m->nDone     - set when a terminating key has been pressed
  1439.    *   m->lRefresh  - indicates the need to get a new set of records
  1440.    *   m->nOldWidth - saves the width of the picklist on-screen
  1441.    *   m->nWidth    - the calculated width of the current picklist
  1442.    *   m->nOldRow   - saves the bottom row of the picklist
  1443.    *   m->nLastBar  - the bottom bar # of the currrent display
  1444.    *   m->nMaxBar   - the maximum number of bars in the list
  1445.    *   m->nLCol     - the leftmost column of the picklist box
  1446.    *   m->nRCol     - the rightmost column of the box
  1447.    *   m->nPKey     - the last key pressed
  1448.    *
  1449.    *   m->nX is used as a loop counter
  1450.  
  1451.  
  1452.    m->nP        = 1
  1453.    m->nO        = 1
  1454.    m->lRefresh  = .t.
  1455.    m->nDone     = iif(reccount() < 1,2,0)
  1456.    m->nWidth    = iif("" <> cTitle,len(cTitle),12)
  1457.    m->nOldWidth = -1
  1458.    m->nOldRow   = -1
  1459.    m->nMaxBar   = (22 - nRow)
  1460.    m->nLastBar  = (nMaxBar - 1)
  1461.    m->nLCol     = nCol
  1462.    m->nRCol     = 77
  1463.    m->nPKey     = 0
  1464.  
  1465.    * Array aBar[] holds the actual contents of the picklist
  1466.  
  1467.    declare aBar[m->nMaxBar]
  1468.  
  1469.    *--------------------------------------------------------------------
  1470.    * Display and process the picklist.
  1471.    *--------------------------------------------------------------------
  1472.  
  1473.    lFirst = .t.
  1474.    do while m->nDone = 0
  1475.  
  1476.       * Check the need for a redraw
  1477.  
  1478.       if lFirst .or. (m->lRefresh .and. .not. eof("picker"))
  1479.          lFirst = .f.
  1480.          m->nWidth = len(cTitle) + 2
  1481.  
  1482.          * Fill aBar[] one record at a time, keep track of the widest
  1483.          * entry (in m->nWidth) for display purposes
  1484.  
  1485.          m->nX = 0
  1486.          do while m->nX < (nMaxBar) .and. .not. eof("picker")
  1487.             m->nX       = m->nX + 1
  1488.             aBar[m->nX] = &clistwhat.
  1489.             if len(aBar[m->nX]) > m->nWidth
  1490.                m->nWidth = len(aBar[m->nX])
  1491.             endif
  1492.             skip 1
  1493.          enddo
  1494.  
  1495.          * If there are no entries, we need to fake a blank one
  1496.          if m->nX = 0
  1497.             aBar[1] = "<No Entries>"
  1498.             m->nX = 1
  1499.          endif
  1500.  
  1501.          * Now that we've filled the array or some portion of it, we
  1502.          * need to make sure we don't exceed the right edge of the
  1503.          * screen.  m->nRCol and m->nLCol will end up holding valid
  1504.          * coordinates that are the right width to display the current
  1505.          * set of records on-screen.
  1506.  
  1507.          m->nLastBar = m->nX
  1508.          m->nLCol    = m->nCol
  1509.          m->nRCol    = m->nLCol + m->nWidth + 4
  1510.          do while (m->nRCol > 77) .and. (m->nLCol > 0)
  1511.             if m->nLCol > 1
  1512.                m->nRCol = m->nRCol - 1
  1513.                m->nLCol = m->nLCol - 1
  1514.             else
  1515.                m->nRCol = 77
  1516.             endif
  1517.          enddo
  1518.  
  1519.          * If our width has changed from the last time, this code will
  1520.          * redraw the box.
  1521.  
  1522.          if (m->nWidth <> m->nOldWidth) .or. (m->nLastBar <> m->nOldRow)
  1523.             restore screen from sPick
  1524.             @ m->nRow+1, m->nLCol+1 fill  to ;
  1525.               m->nRow+m->nLastBar+2,m->nRCol+2 color w/n
  1526.             @ m->nRow  , m->nLCol         to ;
  1527.               m->nRow+m->nLastBar+1,m->nRCol color &cBColor.
  1528.             @ m->nRow  , m->nLCol+1 say '['   color &cBColor.
  1529.             @ m->nRow  , m->nLCol+2 say m->cTitle color &cNColor.
  1530.             @ m->nRow  , m->nLCol+2+len(m->cTitle) say ']' ;
  1531.               color &cBColor.
  1532.          endif
  1533.  
  1534.          * Since there might be leftover records on the screen from the
  1535.          * last time through the loop, we'll clear the internal area of
  1536.          * the picklist box.
  1537.  
  1538.          @ m->nRow+1, m->nLCol+1 clear to m->nRow+m->nLastBar,m->nRCol-1
  1539.  
  1540.          * Now we save the width and the bottom row for comparison next
  1541.          * time through the ringer....
  1542.  
  1543.          m->nOldRow = m->nLastBar
  1544.          m->nOldWidth = m->nWidth
  1545.  
  1546.          * Time to display the contents of the array, which is what the
  1547.          * user sees as the actual list of choices.
  1548.  
  1549.          m->nX = 1
  1550.          do while m->nX <= m->nLastBar
  1551.             @ m->nX+m->nRow,m->nLCol+2 say " "+aBar[m->nX] ;
  1552.               color &cNColor.
  1553.             m->nX = m->nX + 1
  1554.          enddo
  1555.       endif
  1556.  
  1557.       * If PgDn was the last key pressed, we might want to posistion
  1558.       * the selection bar at the end of the list
  1559.  
  1560.       if (m->nPKey = 3) .and. eof("picker")
  1561.          m->nP = m->nLastBar
  1562.       endif
  1563.  
  1564.       * If the box dimensions have changed, we might need to readjust
  1565.       * the position of the selection bar accordingly.
  1566.  
  1567.       if m->nP > m->nLastBar
  1568.          m->nP = m->nLastBar
  1569.       endif
  1570.  
  1571.       * Display the most recently selected bar in the "normal" color
  1572.       * (if necessary), then display the currently selected bar in the
  1573.       * "highlight" color.
  1574.  
  1575.       if m->nO <= m->nLastBar
  1576.          @ m->nRow+m->nO, m->nLCol+2 fill to m->nRow+m->nO,m->nRCol-2 ;
  1577.            color &cNColor.
  1578.       endif
  1579.       @ m->nRow+m->nP, m->nLCol+2 fill to m->nRow+m->nP,m->nRCol-2 ;
  1580.         color &cHColor.
  1581.  
  1582.       * cSeek is the character variable that holds any alphanumeric
  1583.       * keypresses the user might have made.  If not empty, we will
  1584.       * display the appropriate keystrokes as highlighted on the
  1585.       * screen.  This effect is similar to dBASE's own internal pick-
  1586.       * lists.
  1587.  
  1588.       m->nX = at(upper(m->cSeek),upper(aBar[m->nP]))
  1589.       if m->nX > 0
  1590.          @ m->nRow+m->nP,m->nLCol+2+m->nX fill to ;
  1591.            m->nRow+m->nP,m->nLCol+1+m->nX+len(m->cSeek) color &cBColor.
  1592.       endif
  1593.  
  1594.       * We need to save the current bar position for comparison the
  1595.       * next time through the loop.
  1596.  
  1597.       m->nO = m->nP
  1598.  
  1599.       * Process user keystrokes.  Just a big, ugly case construct.
  1600.  
  1601.       m->nPKey = inkey(0)
  1602.       do case
  1603.          case m->nPKey = 5                                 && up
  1604.             m->nP = m->nP - 1
  1605.             if m->nP < 1
  1606.                m->nPKey = 18
  1607.                m->nP = m->nLastBar
  1608.             endif
  1609.             m->cSeek = ""
  1610.          case m->nPKey = 24                                && down
  1611.             m->nP = m->nP + 1
  1612.             if m->nP > m->nLastBar
  1613.                if .not. eof("picker")
  1614.                   m->nPKey = 3
  1615.                   m->nP = 1
  1616.                else
  1617.                   m->nPKey = 0
  1618.                   m->nP = m->nP - 1
  1619.                endif
  1620.             endif
  1621.             m->cSeek = ""
  1622.       endcase
  1623.       m->lRefresh = .t.
  1624.       do case
  1625.          case m->nPKey = 18                                && pgup, up
  1626.             skip - ((nMaxBar * 2) - 2)
  1627.             if bof()
  1628.                m->nPKey = 26
  1629.                go top
  1630.                m->nP = 1
  1631.             endif
  1632.             m->cSeek = ""
  1633.          case m->nPKey = 26                                && home
  1634.             go top
  1635.             m->nP = 1
  1636.             m->cSeek = ""
  1637.          case m->nPKey = 2                                 && end
  1638.             go bottom
  1639.             skip -(nMaxBar-1)
  1640.             if bof()
  1641.                go top
  1642.                m->nP = m->nLastBar
  1643.             else
  1644.                m->nP = m->nMaxBar
  1645.             endif
  1646.             m->cSeek = ""
  1647.          case m->nPKey = 27                                && esc
  1648.             m->nDone = 1
  1649.          case (m->nPKey = 13) .or. (m->nPKey = 23)         && c/r
  1650.             m->nPick = aBar[m->nP]
  1651.             m->nDone = 1
  1652.          case ((m->nPKey >= asc(" ")) .and. (m->nPKey <= asc("z"))) ;
  1653.               .or. (m->nPKey = 127)
  1654.  
  1655.             * Here is where the cSeek variable gets filled with whatever
  1656.             * alphanumeric keys the user might press.  First we verify 
  1657.             * that there's an index tag in use.  If so, we try SEEKing 
  1658.             * the data. If not successful, we try its uppercase 
  1659.             * equivalent just to be sure.  NOTE: This works great with
  1660.             * character-based data.  On any other type of index key, 
  1661.             * you're on your own!
  1662.  
  1663.             * Handle the backspace key here
  1664.             if m->nPKey = 127
  1665.                m->cSeek = left(m->cSeek,len(m->cSeek)-1)
  1666.             else
  1667.                m->cSeek = m->cSeek + chr(m->nPKey)
  1668.             endif
  1669.  
  1670.             * Try the SEEK
  1671.  
  1672.             if .not. isblank(cOrder)
  1673.                seek(m->cSeek)
  1674.                if .not. found()
  1675.                   seek(upper(m->cSeek))
  1676.                endif
  1677.             endif
  1678.  
  1679.             * If unsuccessful, beep at 'em.
  1680.  
  1681.             if .not. found()
  1682.                m->cSeek = left(m->cSeek,len(m->cSeek)-1)
  1683.                ?? chr(7)
  1684.             endif
  1685.  
  1686.             * If the user has pressed the backspace key enough times 
  1687.             * that cSeek is empty, let's rewind to the top of the file.
  1688.  
  1689.             if len(trim(m->cSeek)) = 0
  1690.                go top
  1691.             endif
  1692.  
  1693.             * No matter what, we're gonna want to refresh the data here,
  1694.             * since we've been doing SEEKs and so forth....
  1695.  
  1696.             m->lRefresh = .t.
  1697.             m->nPKey = 3
  1698.          otherwise
  1699.             if (m->nPKey <> 3)
  1700.                m->lRefresh = .f.
  1701.             endif
  1702.       endcase
  1703.    enddo
  1704.  
  1705.    * We'll return either a string of characters or a logical value
  1706.    * depending on the value of the nRetType the program passed us.
  1707.    * If it's a 0, we use KEYBOARD to stuff data into the keyboard
  1708.    * buffer, making a nice hook for READs and so forth.  If nRetType
  1709.    * is non-zero, we return a string 'nRetChar' characters long.
  1710.  
  1711.    if m->nPKey <> 27
  1712.       if m->nreturntype = 0
  1713.          if m->nPick = "<No Entries>"  && Don't send this back!
  1714.             m->nPick = ""
  1715.          endif
  1716.          keyboard chr(26)+chr(25)+left(m->nPick,m->nretchar)+chr(13)
  1717.       endif
  1718.       m->xRetVal = iif(m->nreturntype = 0, .t. , ;
  1719.                  iif(m->nPKey = 27 .or. (m->nPick = "<No Entries>"),"",;
  1720.                      left(m->nPick,m->nretchar)))
  1721.    else
  1722.       m->xRetVal = .f.
  1723.    endif
  1724.  
  1725.    * We've played around a lot here, so we must clean up after our-
  1726.    * selves! After closing the picker work area, we try to make 
  1727.    * everything else look just as it did when we entered the function.
  1728.  
  1729.    use in picker
  1730.  
  1731.    if len(trim(m->cAlias)) > 0
  1732.       select (m->cAlias)
  1733.    endif
  1734.  
  1735.    if len(trim(m->cWindow)) > 0
  1736.       activate window &cWindow.
  1737.    endif
  1738.  
  1739.    do recolor with m->cAttrib
  1740.    set status &cStatus.
  1741.    set talk   &ctalk.
  1742.    set cursor &cCursor.
  1743.    set exact  &cExact.
  1744.    restore screen from sPick
  1745.    release screen sPick
  1746.  
  1747. RETURN m->xRetVal
  1748. *-- EoF: Pick4()
  1749.  
  1750. FUNCTION PopList
  1751. *-----------------------------------------------------------------------
  1752. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1753. *-- Date........: 11/30/1992
  1754. *-- Notes.......: Display a popup constructed from up to 9 options. The 
  1755. *--               routine then keyboards the first characters of the 
  1756. *--               selected option up to the length of the field/memvar) 
  1757. *--               directly into field/memvar. used in place of the 
  1758. *--               picture function "@M" built-in to dBASE IV. This 
  1759. *--               should be used only in a VALID REQUIRED clause, not a 
  1760. *--               WHEN clause. 
  1761. *-- Written for.: dBASE IV, 1.5
  1762. *-- Rev. History: 11/30/1992 -- Original release
  1763. *-- Calls.......: none
  1764. *-- Called by...: Any
  1765. *-- Usage.......: PopList(<cP1>,<cP2>,<cP3>,<cP4>,<cP5>,...<cP9>)
  1766. *-- Example.....: @6,37 get cHanded picture "!" valid required;
  1767. *--                     poplist("Right-handed","Left-handed")
  1768. *--  Returns.....: Logical: .T. when variable being read matches 
  1769. *--                         options, .F. otherwise
  1770. *-- Parameters..: cP1 = First parameter for list
  1771. *--               ...
  1772. *--               cP9 = Last this is max routine will allow ... number 
  1773. *--                     varies, should always have at least two, 
  1774. *--                     otherwise, what's the point? 
  1775. *-----------------------------------------------------------------------
  1776.  
  1777.    parameters cP1, cP2, cP3, cP4, cP5, cP6, cP7, cP8, cP9
  1778.    private nPopLen, nPop, nPopRow, nPopCol, nPopECol, nPopBRow, nPop, ;
  1779.            cPoppar, cPopread, cPopret, nPopInLen, cPopinput
  1780.  
  1781.    m->nPopLen = 0
  1782.    m->nPop    = 0
  1783.    m->cPopread = varread()           && get memvar/field being read
  1784.    m->cPopinput = &cPopread       && store again?
  1785.    m->nPopInLen = len(m->cPopinput)  && get length
  1786.    declare aPopBar[pcount()]      && define array
  1787.    do while m->nPop < pcount()
  1788.       m->nPop = m->nPop + 1
  1789.       m->cPoppar = "cP"+Ltrim(STR(m->nPop))
  1790.       aPopBar[m->nPop] = &cPoppar.
  1791.       m->nPopLen = max(m->nPopLen,len(aPopBar[m->nPop]))
  1792.       if (m->cPopinput=left(aPopBar[m->nPop],m->nPopInLen)) .and. ;
  1793.             (left(aPopBar[m->nPop],m->nPopInLen)=m->cPopinput)
  1794.          RETURN .T.
  1795.       endif
  1796.    enddo
  1797.  
  1798.    *-- set coordinates of popup (checking for edge of screen ...)
  1799.    m->nPopRow = row()
  1800.    m->nPopCol = col() + m->nPopInLen
  1801.    if m->nPopRow + pcount() + 1 > 24
  1802.       m->nPopRow = 23-pcount()
  1803.    endif
  1804.    m->nPopBRow = m->nPopRow + pcount() + 1
  1805.    if m->nPopCol + m->nPopLen > 79
  1806.       m->nPopCol = 75-m->nPopLen
  1807.    endif
  1808.    m->nPopECol = m->nPopCol + m->nPopLen + 1
  1809.   
  1810.    *-- define popup
  1811.    save screen to sPopList
  1812.    define popup PopList from m->nPopRow,m->nPopCol ;
  1813.                         to   m->nPopBRow,m->nPopECol
  1814.    m->nPop = 0
  1815.    do while m->nPop < pcount()
  1816.       m->nPop = m->nPop + 1
  1817.       define bar m->nPop of PopList prompt aPopBar[m->nPop]
  1818.    enddo
  1819.    on selection popup PopList deactivate popup
  1820.    activate popup PopList
  1821.  
  1822.    *-- now we have it, let's deal with output
  1823.    m->cPopret = left(prompt(),m->nPopInLen)
  1824.  
  1825.    *-- cleanup screen and memory
  1826.    release popup PopList
  1827.    restore screen from sPopList
  1828.    release screen sPopList
  1829.  
  1830.    *-- replace data in field for user
  1831.    *-- space is necessary for the valid required error about
  1832.    *--        "Editing condition not satisified ..."
  1833.    *-- chr(26) and chr(25) move cursor to "home" and delete contents
  1834.    *-- of field, so new data can be keyboarded in
  1835.    keyboard " "+chr(26)+chr(25)+m->cPopret + ;
  1836.             iif(set("CONFIRM")="ON",chr(13),"")
  1837.  
  1838. RETURN .F.
  1839. *-- EoF: PopList()
  1840.  
  1841. PROCEDURE Diacrit
  1842. *-----------------------------------------------------------------------
  1843. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1844. *-- Date........: 06/30/1993
  1845. *-- Notes.......: used to insert those letters with diacritical marks 
  1846. *--               into your input screens. This routine brings up a 
  1847. *--               picklist with all the standard diacrit characters 
  1848. *--               built into the ASCII character set. 
  1849. *--               NOTE: To use this routine properly, two things must 
  1850. *--               be done first: 
  1851. *--                  PUBLIC n_rowpop, n_colpop 
  1852. *--                  a Call to LocPop() should be made with a WHEN 
  1853. *--                    clause in the "get". See example below. 
  1854. *-- Written for.: dBASE IV, 1.5
  1855. *-- Rev. History: 12/28/1992 -- Original release
  1856. *--               01/27/1993 -- Modified (KJM) to cope with data entry 
  1857. *--               windows which includes restoring the active window 
  1858. *--               when done. 
  1859. *--               06/30/1993 -- Added optional color parm.
  1860. *-- Calls.......: LocPop()      Indirectly. FUNCTION in PICKLIST.PRG
  1861. *-- Called by...: Any (routine with a get)
  1862. *-- Usage.......: DO Diacrit [with <cColor>]
  1863. *-- Example.....: public n_rowpop, n_colpop         && vital
  1864. *--               @5,10 get cVar when LocPop(5,10)  && vital (if no 
  1865. * --                                                 && border, add ,0 
  1866. *--               on key label ALT-K DO DIACRIT     && after 10)
  1867. *--               read
  1868. *--               on key label alt-k  && release definition
  1869. *-- Returns.....: keyboards character into current "get"
  1870. *-- Parameters..: cColor  = Optional, used to define the colors of the 
  1871. *--                         popup (forg/back) 
  1872. *--                       first pair = background/unselected/box
  1873. *--                       second pair = selected/highlighted 
  1874. *-----------------------------------------------------------------------
  1875.  
  1876.    parameters cColor
  1877.  
  1878.    private nRow, nCol, nRow2, nCol2, cReturn, cTemp1, cTemp2, cOldcol
  1879.    on key label alt-C ?? chr(7)  && beep if user tries to call again ...
  1880.  
  1881.    *-- first things first, define where it's to display
  1882.    m->cWindow = window() && save current window if there is one
  1883.    activate screen
  1884.    m->nRow = m->n_rowpop   && get values from public memvars
  1885.    m->nCol = m->n_colpop
  1886.  
  1887.    *-- bottom right corner of popup ...
  1888.    m->nCol2 = m->nCol + 5
  1889.    m->nRow2 = m->nRow + 10
  1890.  
  1891.    *-- deal with colors if there are any
  1892.    if pcount() > 0
  1893.       m->cOldcol = set("ATTRIBUTE")
  1894.       m->cTemp1 = colorbrk(m->cColor,1)
  1895.       m->cTemp2 = colorbrk(m->cColor,2)
  1896.       set color of message   to &cTemp1.
  1897.       set color of box       to &cTemp1.
  1898.       set color of highlight to &cTemp2.
  1899.    endif
  1900.  
  1901.    *-- define the popup
  1902.    define popup pDiacrit from m->nRow,m->nCol to m->nRow2,m->nCol2
  1903.    define bar  1 of pDiacrit prompt " "+chr(142)+" "  && é
  1904.    define bar  2 of pDiacrit prompt " "+chr(143)+" "  && è
  1905.    define bar  3 of pDiacrit prompt " "+chr(146)+" "  && í
  1906.    define bar  4 of pDiacrit prompt " "+chr(131)+" "  && É
  1907.    define bar  5 of pDiacrit prompt " "+chr(132)+" "  && Ñ
  1908.    define bar  6 of pDiacrit prompt " "+chr(133)+" "  && Ö
  1909.    define bar  7 of pDiacrit prompt " "+chr(134)+" "  && Ü
  1910.    define bar  8 of pDiacrit prompt " "+chr(160)+" "  && †
  1911.    define bar  9 of pDiacrit prompt " "+chr(145)+" "  && ë
  1912.    define bar 10 of pDiacrit prompt " "+chr(144)+" "  && ê
  1913.    define bar 11 of pDiacrit prompt " "+chr(136)+" "  && à
  1914.    define bar 12 of pDiacrit prompt " "+chr(137)+" "  && â
  1915.    define bar 13 of pDiacrit prompt " "+chr(138)+" "  && ä
  1916.    define bar 14 of pDiacrit prompt " "+chr(130)+" "  && Ç
  1917.    define bar 15 of pDiacrit prompt " "+chr(139)+" "  && ã
  1918.    define bar 16 of pDiacrit prompt " "+chr(140)+" "  && å
  1919.    define bar 17 of pDiacrit prompt " "+chr(141)+" "  && ç
  1920.    define bar 18 of pDiacrit prompt " "+chr(161)+" "  && °
  1921.    define bar 19 of pDiacrit prompt " "+chr(147)+" "  && ì
  1922.    define bar 20 of pDiacrit prompt " "+chr(148)+" "  && î
  1923.    define bar 21 of pDiacrit prompt " "+chr(149)+" "  && ï
  1924.    define bar 22 of pDiacrit prompt " "+chr(162)+" "  && ¢
  1925.    define bar 23 of pDiacrit prompt " "+chr(153)+" "  && ô
  1926.    define bar 24 of pDiacrit prompt " "+chr(150)+" "  && ñ
  1927.    define bar 25 of pDiacrit prompt " "+chr(129)+" "  && Å
  1928.    define bar 26 of pDiacrit prompt " "+chr(151)+" "  && ó
  1929.    define bar 27 of pDiacrit prompt " "+chr(163)+" "  && £
  1930.    define bar 28 of pDiacrit prompt " "+chr(154)+" "  && ö
  1931.    define bar 29 of pDiacrit prompt " "+chr(152)+" "  && ò
  1932.    define bar 30 of pDiacrit prompt " "+chr(128)+" "  && Ä
  1933.    define bar 31 of pDiacrit prompt " "+chr(165)+" "  && •
  1934.    define bar 32 of pDiacrit prompt " "+chr(164)+" "  && §
  1935.  
  1936.    *-- whatta we do with it?
  1937.    on selection popup pDiacrit deactivate popup
  1938.    activate popup pDiacrit
  1939.    m->cprompt = prompt()
  1940.  
  1941.    *--            Esc                ->                  <-
  1942.    if lastkey() = 27 .or. lastkey() = 4 .or. lastkey() = 19
  1943.       m->cReturn = ""
  1944.    else
  1945.       m->cReturn = substr(m->cprompt,2,1)  && get the actual character
  1946.    endif
  1947.  
  1948.    *-- remove from memory
  1949.    release popup pDiacrit
  1950.    if pcount() > 0
  1951.       do recolor with m->cOldcol
  1952.    endif
  1953.  
  1954.    *-- reactivate window if there was one ...
  1955.    if .NOT. isblank(m->cWindow)
  1956.       activate window &cWindow.
  1957.    endif
  1958.  
  1959.    *-- put into user's "get"
  1960.    keyboard m->cReturn
  1961.  
  1962.    *-- reset on KEY definition
  1963.    if pcount() > 0
  1964.       on key label alt-C do diacrit with "&cColor."
  1965.    else
  1966.       on key label alt-C do diacrit
  1967.    endif
  1968.  
  1969. RETURN
  1970. *-- EoP: Diacrit
  1971.  
  1972. FUNCTION LocPop
  1973. *-----------------------------------------------------------------------
  1974. *-- Programmer..: Kenneth Chan (:>Zak<:) (CIS: 72662,1305)
  1975. *-- Date........: 01/28/1993
  1976. *-- Notes.......: Created for diacritical routine above, to determine 
  1977. *--               position of current "get", and then decide whether to 
  1978. *--               place upper left coordinates (in public memvars: 
  1979. *--               n_rowpop, n_colpop) of a popup. 
  1980. *-- Written for.: dBASE IV, 1.5
  1981. *-- Rev. History: 12/25/1992 -- Original
  1982. *--               12/28/1992 -- Modified to deal with positioning if 
  1983. *--               get is to far to the right on the screen, and so on 
  1984. *--               (Ken Mayer). 
  1985. *--               01/28/1993 -- Modified to handle windows on screen, 
  1986. *--               giving an absolute address. Requires user to provide 
  1987. *--               coordinates for upper left corner of window. 
  1988. *-- Calls.......: Vidrow()               Function in SCREEN.PRG
  1989. *--               Vidcol()               Function in SCREEN.PRG
  1990. *-- Called by...: Diacrit   (Indirectly) Procedure in PICKLIST.PRG
  1991. *-- Usage.......: LocPop(<nWidth>,<nLength>[,<nWborder>])
  1992. *-- Example.....: @5,10 get cVar when LocPop(5,10)
  1993. *-- Returns.....: logical true
  1994. *-- Parameters..: nWidth   = width of popup
  1995. *--               nLength  = length of popup (how many bars should 
  1996. *--                          display on screen -- used to determine if 
  1997. *--                          displaying above or below row() of get) 
  1998. *--               nWborder = OPTIONAL -- if there is no border we have 
  1999. *--                          to back up one, so put a '0' in here if 
  2000. *--                          there is no border, otherwise, ignore this 
  2001. *--                          parameter. 
  2002. *-----------------------------------------------------------------------
  2003.  
  2004.    parameters nWidth,nLength, nWborder
  2005.    private cVar, nRow, nCol
  2006.  
  2007.    *-- get current "get"
  2008.    m->cVar = varread()
  2009.  
  2010.    *-- puts current position into column/row ... since cursor was just 
  2011.    *-- placed into field (assuming called from WHEN clause), we are 
  2012.    *-- always on the first character in the get ... 
  2013.  
  2014.    m->nRow = Vidrow()
  2015.    m->nCol = Vidcol()
  2016.  
  2017.    if type("NWBorder") # "L" .and. m->nWborder = 0
  2018.       m->nRow = m->nRow - 1
  2019.       m->nCol = m->nCol - 1
  2020.    endif
  2021.  
  2022.    *-- add it all up, see if popup coordinates are off the screen
  2023.    *-- if so, we need to display the popup UNDER the get
  2024.    if m->nCol + (len(&cVar)+m->nWidth+1) > 79
  2025.       m->nRow = m->nRow + 1
  2026.       m->nCol = 79 - m->nWidth && put it right up against edge of screen
  2027.    else                        && otherwise, set column position
  2028.       m->nCol = m->nCol + len(&cVar.) + 1  && add length of memvar/get
  2029.    endif
  2030.  
  2031.    *-- now to see if we're going to go off the bottom of the screen
  2032.    *-- and deal with _that_ -- displaying popup ABOVE the get.
  2033.    m->nDisp = val(RIGHT(set("DISPLAY"),2))  && (EGAxx ...)
  2034.    if m->nRow + m->nLength + 5 => m->nDisp - 1  && check for bottom of 
  2035.       m->nRow = m->nRow - m->nLength - 5        && screen
  2036.    endif
  2037.  
  2038.    if type("N_ROWPOP") = "U" .or. type("N_ROWPOP") = "L"
  2039.       public n_rowpop,n_colpop
  2040.    endif
  2041.    m->n_rowpop = m->nRow  && set current position ...
  2042.    m->n_colpop = m->nCol
  2043.  
  2044. RETURN .T.
  2045. *-- EoF: LocPop()
  2046.  
  2047. *-----------------------------------------------------------------------
  2048. *-- Included below are any auxiliary routines needed for those above.
  2049. *-----------------------------------------------------------------------
  2050.  
  2051. FUNCTION USED
  2052. *-----------------------------------------------------------------------
  2053. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  2054. *-- Date........: 02/28/1992
  2055. *-- Notes.......: Created because the picklist routine by Malcolm Rubel 
  2056. *--               from DBA Magazine (11/91) calls a function that 
  2057. *--               checks to see if a DBF file is open ... 
  2058. *-- Written for.: dBASE IV, 1.5
  2059. *-- Rev. History: 05/15/1992 -- Original
  2060. *--               02/08/1993 -- Discovered (thanks to Jay, and then 
  2061. *--               Malcolm) a much simpler way to do this ... 
  2062. *-- Called by...: Any
  2063. *-- Calls.......: none
  2064. *-- Usage.......: used("<cFile>")
  2065. *-- Example.....: if used("Library")
  2066. *--                  select library
  2067. *--               else
  2068. *--                  select select()
  2069. *--                  use library
  2070. *--               endif
  2071. *-- Returns.....: Logical (.t. if file is in use, .f. if not)
  2072. *-- Parameters..: cFile = file to check for
  2073. *-----------------------------------------------------------------------
  2074.  
  2075.    parameters cFile
  2076.  
  2077. RETURN (select(m->cFile) # 0)
  2078. *-- EoF: used()
  2079.  
  2080. FUNCTION VidRow
  2081. *-----------------------------------------------------------------------
  2082. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  2083. *-- Date........: 01/28/1993
  2084. *-- Notes.......: Calls VDcursor.BIN (David Frankenbach, CIS: 
  2085. *--               72147,2635) to return the ABSOLUTE position of the 
  2086. *--               current ROW on the screen, despite any active 
  2087. *--               windows, etc. This is based on original routines by 
  2088. *--               David Frankenbach, but includes the load/release in 
  2089. *--               one routine, rather than requiring three functions to 
  2090. *--               perform this ... 
  2091. *--               ***************************
  2092. *--               ** REQUIRES VDcursor.BIN **
  2093. *--               ***************************
  2094. *-- Written for.: dBASE IV, 1.5
  2095. *-- Rev. History: 01/28/1993 -- Original release
  2096. *-- Calls.......: VDcursor.BIN
  2097. *-- Called by...: Any
  2098. *-- Usage.......: Vidrow()
  2099. *-- Example.....: ?Vidrow()
  2100. *-- Returns.....: Numeric ROW position for current row on screen
  2101. *-- Parameters..: none
  2102. *-----------------------------------------------------------------------
  2103.  
  2104.    private cX
  2105.  
  2106.    m->cX = space(2)                && define argument memvar
  2107.    load vdcursor                   && load the .BIN file
  2108.    call vdcursor with m->cX        && call it with the memvar
  2109.    release module vdcursor         && release from memory
  2110.  
  2111. RETURN (asc(substr(m->cX,2))-1) && return the value of the absolute 
  2112. *--                             && cursor position 
  2113. *-- EoF: Vidrow()
  2114.  
  2115. FUNCTION VidCol
  2116. *-----------------------------------------------------------------------
  2117. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  2118. *-- Date........: 01/28/1993
  2119. *-- Notes.......: calls VDcursor.BIN (David Frankenbach, CIS: 
  2120. *--               72147,2635) to return the ABSOLUTE position of the 
  2121. *--               current COLUMN on the screen, despite any active 
  2122. *--               windows, etc. This is based on original routines by 
  2123. *--               David Frankenbach, but includes the load/release in 
  2124. *--               one routine, rather than requiring three functions to 
  2125. *--               perform this ... 
  2126. *--               ***************************
  2127. *--               ** REQUIRES VDcursor.BIN **
  2128. *--               ***************************
  2129. *-- Written for.: dBASE IV, 1.5
  2130. *-- Rev. History: 01/28/1993 -- Original release
  2131. *-- calls.......: VDcursor.BIN
  2132. *-- called by...: Any
  2133. *-- Usage.......: Vidcol()
  2134. *-- Example.....: ?Vidcol()
  2135. *-- Returns.....: Numeric COLUMN position for current Col on screen
  2136. *-- Parameters..: none
  2137. *-----------------------------------------------------------------------
  2138.  
  2139.    private cX
  2140.  
  2141.    m->cX = space(2)                && define argument memvar
  2142.    load vdcursor                   && load the .BIN file
  2143.    call vdcursor with m->cX        && call it with the memvar
  2144.    release module vdcursor         && release from memory
  2145.  
  2146. RETURN (asc(subst(m->cX,1))-1) && return the value of the absolute 
  2147. *--                            && cursor position 
  2148. *-- EoF: Vidcol()
  2149.  
  2150.  
  2151. *-----------------------------------------------------------------------
  2152. *-- End of File: PICKLIST.PRG
  2153. *-----------------------------------------------------------------------
  2154.   
  2155.